Delphi 2.0 - Programmer's Utilities Power Pack/Delphi 2.0 Programmer's Utilities Power Pack.iso/s_to_z/tpop3/msgdcd.pas

Pascal/Delphi Source File | 1996-09-15 | 8.9 KB | 366 lines

unit Msgdcd;

interface

uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, StdCtrls,
  Buttons, ExtCtrls, Dialogs, SysUtils, MsgUtils,
  Mime;

type
  EDecodeError = class(Exception);
  TEncMethod = (emNone,emBase64,emQtPrn);

  TSection = class
    EncMethod : TEncMethod;
    FileName : string;
    MIMEType : string;
    Data : TMemoryStream;
    constructor Create;
    destructor Destroy;
  end;

  TMsgProcessor = class(TForm)
    Panel1: TPanel;
    Memo1: TMemo;
    SaveButton: TBitBtn;
    DecodeButton: TBitBtn;
    CloseButton: TBitBtn;
    SaveDialog1: TSaveDialog;
    procedure DecodeButtonClick(Sender: TObject);
    procedure SaveButtonClick(Sender: TObject);
  private
    { Private declarations }
    MsgStream : TMemoryStream;
    Sections : TList;
    MsgLines : TStrings;
    Headers : TStrings;
    procedure FillHeaders;
    procedure ProcessSectionLines(Lines : TStrings);
    procedure HandleSingleSection;
    procedure HandleMultipleSections;
    procedure ProcessSections;
    procedure Process;
    function GetFirstPart(const s : string) : string;
    function GetEncMethod(Hdr : TStrings) : TEncMethod;
  public
    { Public declarations }
    constructor Create(AOwner : TComponent; AStream : TMemoryStream);
    destructor Destroy; override;
  end;

var
  MsgProcessor: TMsgProcessor;
  AttachmentsDir : string;

implementation

{$R *.DFM}

{TSection}
constructor TSection.Create;
begin
  inherited Create;
  Data:=TMemoryStream.Create;
end;

destructor TSection.Destroy;
begin
  Data.Free;
  inherited Destroy;
end;

constructor TMsgProcessor.Create(AOwner : TComponent; AStream : TMemoryStream);
var
  OutFileName : string;
begin
  inherited Create(AOwner);
  MsgStream:=AStream;
  MsgLines:=TStringList.Create;
  MsgStream.Position:=0;
  try
    MsgLines.LoadFromStream(MsgStream);
  except
    on EListError do
    begin
      if MessageDlg('Unable to process this message because it is too large'^M^J+
        'Do you want to save it as file?',mtError,[mbYes,mbCancel],0)=mrYes then
      begin
        AttachmentsDir:=AddBackSlash(AttachmentsDir);
        OutFileName:=AttachmentsDir+'message.txt';
        if InputQuery('Saving a Message','Enter the name of output file:',
                      OutFileName) then
         MsgStream.SaveToFile(OutFileName);
      end;
      DecodeButton.Enabled:=false;
    end;
  end;
  try
    Memo1.Lines:=MsgLines;
  except
    MessageDlg('Text is too large.  Only part will be displayed',
               mtError,[mbOk],0);
  end;
  MsgStream.Position:=0;
  Headers:=TStringList.Create;
  Sections:=TList.Create;
end;

destructor TMsgProcessor.Destroy;
var
  i : Integer;
begin
  for i:=Sections.Count-1 DownTo 0 do
    TSection(Sections[i]).Free;
  Sections.Free;
  Headers.Free;
  MsgLines.Free;
  inherited Destroy;
end;

procedure TMsgProcessor.FillHeaders;
var
  s : string;
begin
  Headers.Clear;
  while (MsgLines.Count<>0) and (MsgLines[0]<>'') do
  begin
    s:=MsgLines[0];
    Headers.Add(s);
    MsgLines.Delete(0);
  end;
end;

function TMsgProcessor.GetFirstPart(const s : string) : string;
{Gets first part of the Header line, where descr is truncated}
var
  sLen : byte absolute s;
  i : byte;
begin
  Result:='';
  i:=1;
  while (i<=sLen) and not (s[i] in [' ',';']) do
  begin
    Result:=Concat(Result,s[i]);
    Inc(i);
  end;
  Result:=TrimStr(Result);
end;

function TMsgProcessor.GetEncMethod(Hdr : TStrings) : TEncMethod;
var
  s : string;
begin
  s:=UpperCase(GetHeaderValue(Hdr,'Content-Transfer-Encoding'));
  if s='BASE64' then
    Result:=emBase64
  else
  if s='QUOTED-PRINTABLE' then
    Result:=emQtPrn
  else
    Result:=emNone;
end;

procedure TMsgProcessor.ProcessSectionLines(Lines : TStrings);
var
  LocalHeaders : TStrings;
  TempSection : TSection;
  s : string;
begin
  LocalHeaders:=TStringList.Create;
  try
    while (Lines.Count<>0) and (Lines[0]<>'') do
    begin
      s:=Lines[0];
      LocalHeaders.Add(s);
      Lines.Delete(0);
    end;
    TempSection:=TSection.Create;
    s:=GetHeaderValue(LocalHeaders,'Content-Type');
    if s=InvStr then
    begin
      TempSection.Free;
      raise EDecodeError.Create('Missing required field - Content-Type');
    end;
    TempSection.MimeType:=GetFirstPart(s);
    if Pos('PARTIAL',UpperCase(TempSection.MimeType))>0 then
      raise EDecodeError.Create('Unable to handle multipart messages');
    s:=GetParameter('name',s);
    if s<>InvStr then
      TempSection.FileName:=s;
    s:=GetHeaderValue(LocalHeaders,'Content-Disposition');
    s:=GetParameter('filename',s);
    if s<>InvStr then
      TempSection.FileName:=s;
    TempSection.EncMethod:=GetEncMethod(LocalHeaders);
    Lines.SaveToStream(TempSection.Data);
    TempSection.Data.Position:=0;
    Sections.Add(TempSection);
  finally
    LocalHeaders.Free;
  end;
end;

procedure TMsgProcessor.HandleSingleSection;
var
  TempLines : TStrings;
begin
  TempLines:=TStringList.Create;
  TempLines.AddStrings(Headers);
  try
    TempLines.AddStrings(MsgLines);
    ProcessSectionLines(TempLines);
  finally
    TempLines.free;
  end;
end;

procedure TMsgProcessor.HandleMultipleSections;
var
  TempLines : TStrings;
  Boundary : string;
  s : string;
  i : Integer;
  Finished : boolean;
  BLen : byte;
begin
  s:=GetHeaderValue(Headers,'Content-Type');
  Boundary:='';
  if Pos('MULTIPART',UpperCase(s))<>0 then
    Boundary:=GetParameter('Boundary',s);
  if Boundary=InvStr then
    raise EDecodeError.Create('Miltipart message does not contain'^M^J+
                              '   the ''boundary'' parameter.');
  if Boundary<>'' then
  begin
    if Boundary<>'' then Boundary:=Concat('--',Boundary);
    BLen:=Length(Boundary);
    try
      TempLines:=TStringList.Create;
      i:=0;
      while (i<MsgLines.Count) and (Copy(MsgLines[i],1,BLen)<>Boundary) do
        Inc(i);
      if i=MsgLines.Count then
        raise EDecodeError.Create('Invalid format.');
    repeat
      Inc(i);
      TempLines.Clear;
      while (i<MsgLines.Count) and (Copy(MsgLines[i],1,BLen)<>Boundary) do
      begin
        TempLines.Add(MsgLines[i]);
        Inc(i);
      end;
      Finished:=(i=MsgLines.Count) or (MsgLines[i]=Concat(Boundary,'--'));
      ProcessSectionLines(TempLines);
    until Finished;
    finally
      TempLines.Free;
    end;
  end
  else
    HandleSingleSection;
end;

procedure TMsgProcessor.ProcessSections;
var
  i : Integer;
  TempLines : TStringList;
  TempStream : TMemoryStream;
  Section : TSection;
begin
  MsgLines.Clear;
  TempLines:=TStringList.Create;
  TempStream:=TMemoryStream.Create;
  try
    for i:=0 to Sections.Count-1 do
    begin
      Section:=TSection(Sections[i]);
      case Section.EncMethod of
        emNone :
        begin
          TempLines.LoadFromStream(Section.Data);
          MsgLines.AddStrings(TempLines);
        end;
        emBase64:
        begin
          TempLines.LoadFromStream(Section.Data);
          TrimStringList(TempLines);
          TempStream.Clear;
          with TBase64.Create(TempStream,TempLines) do
          try
            Decode;
          finally
            free;
          end;
          TempStream.SaveToFile(AttachmentsDir+Section.FileName);
          MsgLines.Add('--Section '+IntToStr(i)+'--');
          MsgLines.Add('Decoded and saved as '+AttachmentsDir+Section.FileName);
          MsgLines.Add('----');
        end;
        emQtPrn :
        begin
          TempLines.LoadFromStream(Section.Data);
          TrimStringList(TempLines);
          TempStream.Clear;
          with TQuotedPrintable.Create(TempStream,TempLines) do
          try
            Decode;
          finally
            free;
          end;
          TempStream.Position:=0;
          TempLines.Clear;
          TempLines.LoadFromStream(TempStream);
          MsgLines.AddStrings(TempLines);
        end;
      end;
    end;
  finally
    TempStream.Free;
    TempLines.Free;
  end;
end;

procedure TMsgProcessor.Process;
var
  TempSection : TSection;
  i : Integer;
begin
  FillHeaders;
  if GetHeaderValue(Headers,'Mime-Version')<>'1.0' then
    HandleSingleSection
  else
    HandleMultipleSections;
  ProcessSections;
end;

procedure TMsgProcessor.DecodeButtonClick(Sender: TObject);
begin
  AttachmentsDir:=AddBackSlash(AttachmentsDir);
  Memo1.Cursor:=crHourGlass;
  Panel1.Cursor:=crHourGlass;
  Panel1.Enabled:=false;
  try
    Process;
    Memo1.Lines:=MsgLines;
  finally
    Memo1.Cursor:=crDefault;
    Panel1.Cursor:=crDefault;
    Panel1.Enabled:=true;
    DecodeButton.Enabled:=false;
  end;
end;

procedure TMsgProcessor.SaveButtonClick(Sender: TObject);
begin
  SaveDialog1.InitialDir:=AttachmentsDir;
  if SaveDialog1.Execute then
  begin
    MsgStream.SaveToFile(SaveDialog1.FileName);
  end;
end;

initialization
  AttachmentsDir:='';
end.